Programmer Plus 2007/Programmer-Plus-2007.iso/Programming/SQL and Data Base/Logic Works ERwin 3.5/data.1/ERWIN40.BAS

BASIC Source File | 1997-06-02 | 20.1 KB | 753 lines

Attribute VB_Name = "Module2"
Option Explicit

Type TranslateItem
    Item As Variant ' index into control or field array
    Value As Variant
End Type

Type ListItem
    DisplayVal As String
    DataVal As String
End Type

#If Win32 Then ' 32-bit VB uses this Declare.
    Declare Function GetWindowLong Lib "user32" Alias "GetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long) As Long
    Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
#Else   ' 16-bit VB uses this Declare.
    Declare Function GetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer) As Long
    Declare Function SetWindowLong Lib "User" (ByVal hwnd As Integer, ByVal nIndex As Integer, ByVal dwNewLong As Long) As Long
#End If


Function er_CB_ControlValue(cb As Control, fld As Field) As Variant
    er_CB_ControlValue = er_CB_ControlXlateValue(cb, fld, "Y", "N")

End Function

Function er_CB_ControlXlateValue(cb As Control, fld As Field, sOn As String, sOff As String) As Variant
    Dim nValue As Integer
    Dim sValue As String
    Dim sMsg As String
    Dim nOff As Integer
    Dim nOn As Integer


    Select Case Abs(cb.Value)
    Case 0
        sValue = sOff
        nValue = Val(sOff)
    Case 1
        sValue = sOn
        nValue = Val(sOn)
    Case Else
        sValue = ""
    End Select

    Select Case True
    Case er_FieldIsNumeric(fld)
        er_CB_ControlXlateValue = nValue
    Case er_FieldIsString(fld)
        er_CB_ControlXlateValue = sValue
    Case Else
        Beep
        sMsg = fld.Name & " uses a data type that is not supported by ERwin's code translation feature."
        MsgBox sMsg, MB_OK + MB_ICONEXCLAMATION, "ERwin for Visual Basic"
    End Select

End Function

Function er_CB_FieldValue(cb As Control, fld As Field) As Integer
    er_CB_FieldValue = er_CB_FieldXlateValue(cb, fld, "Y", "N")

End Function

Function er_CB_FieldXlateValue(cb As Control, fld As Field, sOn As String, sOff As String) As Integer
    Dim sMsg As String
    Dim sBuff As String


    If IsNull(fld) Then
        er_CB_FieldXlateValue = 2
    Else
        Select Case True
        Case er_FieldIsNumeric(fld)
            If fld = Val(sOff) Then
                er_CB_FieldXlateValue = 0
            ElseIf fld = Val(sOn) Then
                er_CB_FieldXlateValue = 1
            Else
                er_CB_FieldXlateValue = 2
            End If
        Case er_FieldIsString(fld)
            sBuff = fld
            sBuff = Trim(sBuff)

            If sBuff = sOff Then
                er_CB_FieldXlateValue = 0
            ElseIf sBuff = sOn Then
                er_CB_FieldXlateValue = 1
            Else
                er_CB_FieldXlateValue = 2
            End If
        Case Else
            Beep
            sMsg = fld.Name & " uses a data type that is not supported by ERwin's code translation feature."
            MsgBox sMsg, MB_OK + MB_ICONEXCLAMATION, "ERwin for Visual Basic"
        End Select
    End If

End Function

Function er_CurrRowExists(ds As Data)
    Dim sBookMark As String
    Dim vValue As Variant

    On Error GoTo CurrRowExists_Handler
    er_CurrRowExists = True

    ' Try to cause the "no current record" error
    vValue = ds.Recordset.Fields(0)

    If ds.EditMode = DATA_EDITADD Then
        er_CurrRowExists = False
    End If

    Exit Function

CurrRowExists_Handler:
    Select Case Err
        Case 3021   ' Error: No current record
            er_CurrRowExists = False
            Resume Next
        Case 91     ' Object variable not set
            er_CurrRowExists = False
            Resume Next
        Case Else
            er_DisplayError (Err)
            Resume Next
    End Select

End Function

Sub er_DeleteButton(ds As Data)
    If ds.EditMode <> DATA_EDITADD Then
        er_ffDeleteRow ds
    Else
        MoveFromCurrRow ds
    End If

End Sub

Sub er_DisplayError(ErrNum As Integer)
    Beep
    MsgBox "Error:" & Str(ErrNum) & " - " & Error(ErrNum)

End Sub

Sub er_DS_Update(Frm As Form, ds As Data, nNoRepos As Integer, bUpdateFailed As Integer)
    Dim bNew As Integer
    Dim bUpdating As Integer

    On Error GoTo DS_Update_Handler

    bUpdateFailed = False   'MAR

    If er_CurrRowExists(ds) = False Then
        bNew = True
    End If

'    If er_CurrRowExists(ds) Or ds.EditMode = DATA_EDITADD Then  'MAR
    If ds.EditMode <> DATA_EDITNONE Then
        nNoRepos = nNoRepos + 1
        bUpdating = True
        ds.Recordset.Update
        bUpdating = False
        nNoRepos = nNoRepos - 1

        If bNew And Not bUpdateFailed And ds.Recordset.RecordCount Then
            ds.Recordset.MoveLast
            bNew = False
        End If
    End If

    Exit Sub

DS_Update_Handler:

    Select Case Err
        Case 3020   ' Error: Update without Add New or Edit
            Resume Next

        Case 3021   ' Error: No current record
            Resume Next

        Case Else
            er_DisplayError (Err)
            If bUpdating Then bUpdateFailed = True  'MAR
            Resume Next
    End Select


End Sub

Sub er_ffDeleteRow(ds As Data)
    Dim bLastRecord As Variant

    If ds.Recordset.RecordCount = 0 Then Exit Sub

    On Error GoTo ErrorHandler
    bLastRecord = False

    If ds.Recordset.AbsolutePosition = (ds.Recordset.RecordCount - 1) Then
        bLastRecord = True
    End If
    ds.Recordset.Delete
    If Not er_CurrRowExists(ds) Then
        MoveFromCurrRow ds, bLastRecord
    End If
    If ds.Recordset.RecordCount = 0 Then
        'ds.Recordset.AddNew    'MAR replaced by next line
        ds.Refresh
    End If

er_ffDeleteRow_Done:
    Exit Sub

ErrorHandler:

    Select Case Err
        'Case 3197   ' Error: Data has changed, operation stopped
        '    ds.Recordset.Update
        '    Resume Next

        Case 3021   ' Error: No current record
            Resume Next

        Case 444    ' Method not applicable in this context
            Resume Next

        Case Else
            er_DisplayError (Err)
            Resume er_ffDeleteRow_Done
    End Select

End Sub

Function er_FieldIsNumeric(fld As Field) As Integer
    Select Case fld.Type
    Case DB_BOOLEAN
        er_FieldIsNumeric = True
    Case DB_BYTE
        er_FieldIsNumeric = True
    Case DB_INTEGER
        er_FieldIsNumeric = True
    Case DB_LONG
        er_FieldIsNumeric = True
    Case DB_CURRENCY
        er_FieldIsNumeric = True
    Case DB_SINGLE
        er_FieldIsNumeric = True
    Case DB_DOUBLE
        er_FieldIsNumeric = True
    Case Else
        er_FieldIsNumeric = False
    End Select

End Function

Function er_FieldIsString(fld As Field) As Integer
    Select Case fld.Type
    Case DB_TEXT
        er_FieldIsString = True
    Case DB_LONGBINARY
        er_FieldIsString = True
    Case DB_MEMO
        er_FieldIsString = True
    Case Else
        er_FieldIsString = False
    End Select

End Function

Function er_NullValue(fld As Field) As Variant
    Select Case fld.Type
    Case DB_BOOLEAN
        er_NullValue = 0
    Case DB_BYTE
        er_NullValue = 0
    Case DB_INTEGER
        er_NullValue = 0
    Case DB_LONG
        er_NullValue = 0
    Case DB_CURRENCY
        er_NullValue = 0
    Case DB_SINGLE
        er_NullValue = 0
    Case DB_DOUBLE
        er_NullValue = 0
    Case DB_DATE
        er_NullValue = ""
    Case DB_TEXT
        er_NullValue = ""
    Case DB_LONGBINARY
        er_NullValue = ""
    Case DB_MEMO
        er_NullValue = ""
    End Select

End Function

Function er_ObjectSet(ds As Data) As Integer
    Dim iMode As Integer
    On Error GoTo ObjectSet_Handler

    er_ObjectSet = True

    ' Try to cause an error by accessing the data control
    If ds.EditMode = DATA_EDITADD Then iMode = 0 'no op

    Exit Function

ObjectSet_Handler:
    Select Case Err
    Case 91
        er_ObjectSet = False
        Resume Next

    Case Else
        er_DisplayError (Err)
        Resume Next
    End Select
End Function

Function er_PreValidate(ds As Data, Action As Integer, Save As Integer) As Integer
    er_PreValidate = False

    Select Case Action
'    Case DATA_ACTIONMOVEFIRST To DATA_ACTIONMOVELAST, DATA_ACTIONDELETE    'MAR changed
    Case DATA_ACTIONMOVEFIRST To DATA_ACTIONMOVELAST
        If ds.Recordset.RecordCount = 0 And Save = False Then
            'Action = DATA_ACTIONCANCEL 'MAR removed
            Save = False
            er_PreValidate = True
        End If

    Case DATA_ACTIONDELETE
        If ds.Recordset.RecordCount = 0 And Save = False Then
            Action = DATA_ACTIONCANCEL
            Save = False
            er_PreValidate = True
        End If

    Case DATA_ACTIONUPDATE
        If Save = False Then
            Action = DATA_ACTIONCANCEL
            er_PreValidate = True
        End If

    Case DATA_ACTIONBOOKMARK
        er_PreValidate = True
    End Select

    Exit Function

PreVal_Handler:
    Select Case Err
        Case 3021   ' Error: No current record
            Beep
            Resume Next

        Case Else
            er_DisplayError (Err)
            Resume Next
    End Select

End Function

Sub er_SetEditMode(ds As Data)
    On Error GoTo SetEditMode_Handler

    If er_CurrRowExists(ds) And ds.EditMode = DATA_EDITNONE Then
        ds.Recordset.Edit
    End If

    Exit Sub

SetEditMode_Handler:
    Select Case Err
        'Case 3197   ' Error: Data has changed, operation stopped
        '    Resume Next

        Case Else
            er_DisplayError (Err)
            Resume Next
    End Select

End Sub

Sub er_SetFieldToNull(fld As Field)
    Select Case fld.Type
    Case DB_BOOLEAN
        fld = 0
    Case DB_BYTE
        fld = 0
    Case DB_INTEGER
        fld = 0
    Case DB_LONG
        fld = 0
    Case DB_CURRENCY
        fld = 0
    Case DB_SINGLE
        fld = 0
    Case DB_DOUBLE
        fld = 0
    Case DB_DATE
        fld = Date
    Case DB_TEXT
        fld = ""
    Case DB_LONGBINARY
        fld = ""
    Case DB_MEMO
        fld = ""
    End Select

End Sub

Function er_SQLValue(ds As Data, sFldName As String)
    Dim bQuotes As Integer
    Dim sValue As String
    Dim vValue As Variant

    Select Case ds.Recordset(sFldName).Type
    Case DB_TEXT
        bQuotes = True
    Case DB_MEMO
        bQuotes = True
    Case Else
        bQuotes = False
    End Select

    If IsNull(ds.Recordset(sFldName)) Then
        vValue = er_NullValue(ds.Recordset(sFldName))
        sValue = vValue
    Else
        sValue = LTrim(RTrim(ds.Recordset(sFldName)))
    End If

    If bQuotes Then
        sValue = "'" & sValue & "'"
    End If

    er_SQLValue = sValue

End Function

Function erwAddDisplayFieldTranslation(ctlData As Data, strFieldName As String, varValue As Variant, udtTranslateList() As TranslateItem, nListCount As Integer)
    Dim nTmpListCount As Integer
    Dim nTmpListBound As Integer
    Dim udtTmpTranslateItem As TranslateItem

    nTmpListCount = nListCount
'   nTmpListBound = UBound(udtTranslateList)

'    If nTmpListBound = nTmpListCount Then
'        ReDim udtTranslateList(nTmpListBound + 20)
'    End If

    udtTmpTranslateItem.Item = ctlData.Recordset.Fields(strFieldName).OrdinalPosition
    udtTmpTranslateItem.Value = varValue
    udtTranslateList(nTmpListCount) = udtTmpTranslateItem

    erwAddDisplayFieldTranslation = nTmpListCount + 1
End Function

Function erwDoDisplayFieldTranslation(ctlData As Data, TranslateList() As TranslateItem, nListCount As Integer)
    Dim i As Integer
    Dim nCount As Integer

    For i = 0 To nListCount - 1
        If TranslateList(i).Item >= 0 Then
            ctlData.Recordset.Fields(TranslateList(i).Item) = TranslateList(i).Value
            nCount = nCount + 1
        End If
    Next
    erwDoDisplayFieldTranslation = True
End Function

Sub erwGetNewListField(ListCtrl As Control, DataCtrl As Data, FieldName As String, ListItems() As ListItem, bNoClick As Integer)
    Dim GstrCount As Integer
    Dim GStrIndex As Integer
    Dim ListCount As Integer
    Dim i As Integer
    Dim FieldValue As String
    Dim DisplayValue As String

    Err = 0
    GStrIndex = -1
    On Error Resume Next
    If IsNull(DataCtrl.Recordset.Fields(FieldName)) Then
        FieldValue = ""
    Else
        FieldValue = Trim(DataCtrl.Recordset.Fields(FieldName))
    End If
    GstrCount = UBound(ListItems)
    For i = LBound(ListItems) To GstrCount - 1
        If ListItems(i).DataVal = FieldValue Then
            GStrIndex = i
            DisplayValue = ListItems(i).DisplayVal
            Exit For
        End If
    Next

    If GStrIndex = -1 Then
        bNoClick = True
        ListCtrl.ListIndex = -1
        bNoClick = False
        If TypeOf ListCtrl Is ComboBox Then
            bNoClick = True
            ListCtrl.Text = FieldValue
            bNoClick = False
        End If
    Else
'                ListCtrl.Text = DisplayValue
        ListCount = ListCtrl.ListCount
        For i = 0 To ListCount - 1
            If ListCtrl.ItemData(i) = GStrIndex Then
                bNoClick = True
                ListCtrl.ListIndex = i
                bNoClick = False
                Exit For
           End If
        Next
    End If
End Sub

Function erwSetNewListField(ListCtrl As Control, DataCtrl As Data, FieldName As String, ListItems() As ListItem, bValidate As Integer, bNoClick As Integer)
    Dim i As Integer
    Dim ListIndex As Integer
    Dim GStrIndex As Long
    Dim FieldValue As String
    Dim bRetVal

    bRetVal = True
    Err = 0
    On Error Resume Next
    ListIndex = ListCtrl.ListIndex

        'If no list selection, see if typed in text is on list and select it if so
    If ListIndex = -1 Then
        If TypeOf ListCtrl Is ComboBox Then
                For i = 0 To ListCtrl.ListCount - 1
                    If ListCtrl.List(i) = ListCtrl.Text Then
                        bNoClick = True
                        ListCtrl.ListIndex = i
                        bNoClick = False
                        Exit For
                    End If
                Next
                End If
        End If

    'If still no selection, do validation/translation
    ListIndex = ListCtrl.ListIndex
        If ListIndex = -1 Then
            If bValidate Then
                bRetVal = False
            Else
                DataCtrl.Recordset.Fields(FieldName) = ListCtrl.Text
            End If
        Else
            GStrIndex = ListCtrl.ItemData(ListIndex)
            FieldValue = ListItems(GStrIndex).DataVal
            DataCtrl.Recordset.Fields(FieldName) = FieldValue
    End If

    erwSetNewListField = bRetVal
End Function

Sub MoveFromCurrRow(ds As Data, Optional bLastRecord As Variant)
    On Error GoTo MoveFrom_Handler

    If bLastRecord Then
        ds.Recordset.MoveLast
    Else
        ds.Recordset.MoveNext
    End If

    If ds.Recordset.EOF Then
        If ds.Recordset.RecordCount > 0 Then
            ds.Recordset.MovePrevious
        Else
            ds.Recordset.AddNew
        End If
    End If

    Exit Sub

MoveFrom_Handler:
    Select Case Err
        Case 3021   ' Error: No current record
            Resume Next

        Case Else
            er_DisplayError (Err)
            Resume Next
    End Select

End Sub


Public Sub er_NewButton(Frm As Form, ds As Data, nNoRepos As Integer, bUpdateFailed As Integer)

    bUpdateFailed = False   'MAR, MB2
    'If er_CurrRowExists(ds) And ds.EditMode <> dbEditNone Then  'MAR line replaced
    If ds.EditMode <> dbEditNone Then
        er_DS_Update Frm, ds, nNoRepos, bUpdateFailed
    End If

    If Not bUpdateFailed Then   'MAR
        ds.Recordset.AddNew
    End If  'MAR

End Sub

Public Sub er_LoadList(ListCtrl As Control, ListItems() As ListItem)
    Dim i As Integer

    For i = LBound(ListItems) To UBound(ListItems) - 1
        ListCtrl.AddItem ListItems(i).DisplayVal
        ListCtrl.ItemData(ListCtrl.NewIndex) = i
    Next
End Sub

Public Function er_ErrorPrompt(ErrNum As Integer, sQuestion As String, nButtons As Integer, sTitle As String)
    Dim sMsg As String

    If sQuestion = "" Then
        sQuestion = "Do you wish to retry the operation?"
        nButtons = vbYesNo Or vbExclamation
    End If

    If sTitle = "" Then
        sTitle = "Application Error"
    End If

    Beep
    sMsg = "Error:" & Str(ErrNum) & " - " & Error(ErrNum)
    sMsg = sMsg + String(2, Chr(13)) & sQuestion
    er_ErrorPrompt = MsgBox(sMsg, nButtons, sTitle)

End Function

Public Function er_ActionNeedsUpdate(Action As Integer)
    Select Case Action
        Case DATA_ACTIONMOVEFIRST To DATA_ACTIONMOVELAST
            er_ActionNeedsUpdate = True
        Case DATA_ACTIONADDNEW, DATA_ACTIONDELETE
            er_ActionNeedsUpdate = True
        Case DATA_ACTIONCLOSE, DATA_ACTIONUNLOAD
            er_ActionNeedsUpdate = True
        Case DATA_ACTIONBOOKMARK
            er_ActionNeedsUpdate = True
        Case Else
            er_ActionNeedsUpdate = False
    End Select
End Function

Public Function er_DS_FieldsAvailable(ds As Data)
    er_DS_FieldsAvailable = er_CurrRowExists(ds) Or ds.EditMode <> DATA_EDITNONE
End Function


Public Sub er_SaveChangedFlags(axCtrl() As Control, abFlag() As Integer)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axCtrl)

    For i = LBound(axCtrl) To iMax - 1
        abFlag(i) = axCtrl(i).DataChanged
    Next i

End Sub

Public Sub er_RestoreChangedFlags(axCtrl() As Control, abFlag() As Integer)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axCtrl)

    For i = LBound(axCtrl) To iMax - 1
        axCtrl(i).DataChanged = abFlag(i)
    Next i

End Sub

Public Sub er_ClearChangedFlags(axCtrl() As Control, abFlag() As Integer)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axCtrl)

    For i = LBound(axCtrl) To iMax - 1
        axCtrl(i).DataChanged = False
        abFlag(i) = False
    Next i

End Sub

' Translates a data value into a display value using the specified ListItem array
' sDataVal: (Input)The data value to translate
' axList(): (Input) The ListItem array
' sDisplayVal: (Output) The translated value
' Returns: True if sDataVal was found in the list, sDisplayVal is the translated value.
'          False if sDataVal was not found in the list, sDisplayVal is sDataVal.
'==================================================================================
Public Function er_GetDisplayValue(sDataVal As String, axList() As ListItem, sDisplayVal As String)
    Dim iMax As Integer
    Dim i As Integer
    Dim sTrimmedString As String

    sTrimmedString = Trim(sDataVal)
    iMax = UBound(axList)

    For i = LBound(axList) To iMax - 1
        If sTrimmedString = axList(i).DataVal Then
            sDisplayVal = axList(i).DisplayVal
            er_GetDisplayValue = True
            Exit Function
        End If
    Next i

    er_GetDisplayValue = False
    sDisplayVal = sTrimmedString

End Function

' Translates a display value into a data value using the specified ListItem array
' sDisplayVal: (Input)The display value to translate
' axList(): (Input) The ListItem array
' sDataVal: (Output) The translated value
' Returns: True if sDisplayVal was found in the list, sDataVal is the translated value.
'          False if sDisplayVal was not found in the list, sDataVal is sDisplayVal.
'==================================================================================
Public Function er_GetDataValue(sDisplayVal As String, axList() As ListItem, sDataVal As String)
    Dim iMax As Integer
    Dim i As Integer

    iMax = UBound(axList)

    For i = LBound(axList) To iMax - 1
        If sDisplayVal = axList(i).DisplayVal Then
            sDataVal = axList(i).DataVal
            er_GetDataValue = True
            Exit Function
        End If
    Next i

    er_GetDataValue = False
    sDataVal = sDisplayVal

End Function